#!/usr/bin/perl

=pod

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2012 of Alceu Rodrigues de Freitas Junior, E<lt>arfreitas@cpan.org<E<gt>

This project is based on the code (SiebelOVAnalyzer) provided in the article "Memory Leaks in 
Siebel" (http://siebelunleashed.com/memory-leaks-siebel/) from Timur Vafin. 

This file is part of Siebel Code Analyzer.

Siebel Code Analyzer is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

Siebel Code Analyzer is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with Siebel Monitoring Tools.  If not, see <http://www.gnu.org/licenses/>.

=cut

use warnings;
use strict;
use DBI qw(:sql_types);
use Cwd;
use Digest::MD5 qw(md5_base64);
use Encode qw(decode);
use feature 'switch';
use AppConfig qw(:argcount);
use File::Spec::Functions;
use lib '.';
use Siebel::Code::Analyzer::DAOFactory;
use constant DEBUG => 0;
use XML::Writer;
use IO::File;
use Getopt::Long qw(:config auto_version auto_help);
use Pod::Usage;

my $VERSION = 0.04;

my $config_file = 'finder.cfg';
my $cfg         = read_config($config_file);

my $dao = Siebel::Code::Analyzer::DAOFactory->create(
    $cfg->data_source(),
    {
        data_source    => $cfg->data_source(),
        user           => $cfg->user(),
        password       => $cfg->password(),
        max_long       => $cfg->maximum_long(),
        repo_name      => $cfg->repository_name(),
        last_upd       => $cfg->last_update(),
        skip_inactive  => $cfg->skip_inactive(),
        verify_runtime => $cfg->verify_runtime()
    }
);

my %programs;
my %variables;

$| = 1;
print 'Parsing scripts... ';

my $scripts_ref = $dao->get_repo_data();

foreach my $script ( @{$scripts_ref} )
{    # $script is a Siebel::Code::Analyzer::Script

    # resets the variable at each new script
    my $comm_flg = 0;

    my @code_lines = split( /\n/, $script->get_code() );
    my $program_id;

 # this will help identify when non-UTF8 data is recovered from the database
 # the md5_base64 function will die in those cases when data cannot be converted
    eval {

        $program_id =
          md5_base64( $script->get_repo_name()
              . $script->get_type()
              . $script->get_name()
              . $script->get_script_name()
              . $script->get_last_upd() );

    };

    if ($@) {

        warn "Failed to to parse data: $@";
        warn "Dumping data read";
        print '-' x 5, "\n";
        print Dumper($script), "\n";
        print '-' x 5, "\n";
        next;

    }

    foreach my $line (@code_lines) {

        given ($line) {

            chomp($line);

            when (/^[\t\s]?$/) {

                print "Skipping empty line: $line\n" if (DEBUG);

            }

            when (/^\/\//) {

                print "Skipping commented line: $line\n" if (DEBUG);

            }

            when (/^[\t\s]+\/\//) {

                print "Skipping commented line: $line\n" if (DEBUG);

            }

            when (/\/\*.*\*\//) {

                print "Skipping commented line: $line\n" if (DEBUG);

            }

            when (/\/\*+/) {

                $comm_flg = 1;
                print "Start of comment: $line\n" if (DEBUG);

            }
            when (/\*+\//) {

                $comm_flg = 0;
                print "End of comment: $line\n" if (DEBUG);

            }
            default {    #      Search for variables

                my $invoke_method = check_method($line);

                given ($line) {

                    when ( $comm_flg == 1 ) {

                        print "Skipped commented code: $line\n" if (DEBUG);

                    }

                    # declaration of a object
                    when ( defined($invoke_method) ) {

                        $line =~ s/^[\s\t]*//;
                        $line =~ s/var[\s\t]*//;
                        $line =~ s/[\s\t]*=.*//;
                        $line =~ s/:.*//;
                        $line =~ s/\(//g;
                        $line =~ s/\)//g;

                        if (    ( $line !~ /\[|if|return|while|^\&\&|^\|\|/ )
                            and ( $line !~ /^\/\/|\/\*/ ) )
                        {
                            if ( $line =~ /\=/ ) {

                                $line =~ s/[\s\t]*//g;

                                foreach my $litem ( split( '=', $line ) ) {

                                    my $var_id =
                                      md5_base64( $script->{repo_name}
                                          . $script->{obj_type}
                                          . $script->{app_name}
                                          . $script->{script_name}
                                          . $script->{last_upd}
                                          . $litem );

                                    $variables{$var_id} = {
                                        program_id    => $program_id,
                                        is_nullified  => 0,
                                        name          => $litem,
                                        assign_method => $invoke_method
                                    };

                                    # forces parent data into it
                                    add_parent_data( \%variables, $var_id,
                                        $script );

                                }

                            }
                            else {

                                my $var_id =
                                  md5_base64( $script->get_repo_name()
                                      . $script->get_type()
                                      . $script->get_name()
                                      . $script->get_script_name()
                                      . $script->get_last_upd()
                                      . $line );

                                $variables{$var_id} = {
                                    program_id    => $program_id,
                                    is_nullified  => 0,
                                    name          => $line,
                                    assign_method => $invoke_method
                                };

                                # forces parent data into it
                                add_parent_data( \%variables, $var_id,
                                    $script );

                            }
                        }
                    }    # end of when

                    #   Search for variables that become null
                    when ( $line =~ /\=[\s\t]*null/ ) {

                        $line =~ s/^[\s\t]*//;
                        $line =~ s/[\s\t]*=[\s\t]*null.*//;

             # :TODO:26/10/2011 12:32:53:: break this to several when statements
                        if ( $line !~
                            /\[|^var[\s\t]*|if|return|while|^\&\&|^\|\|/ )

                        {
                            if ( $line =~ /\=/ ) {

                                $line =~ s/[\s\t]*//g;

                                # include multiple variables assignments
                                foreach my $litem ( split( '=', $line ) ) {

                                    my $var_id =
                                      md5_base64( $script->get_repo_name()
                                          . $script->get_type()
                                          . $script->get_name()
                                          . $script->get_script_name()
                                          . $script->get_last_upd()
                                          . $litem );

                                    if ( exists( $variables{$var_id} ) ) {

                                        $variables{$var_id}->{is_nullified} = 1;

                                     # parent data will not be necessary anymore
                                        delete( $variables{$var_id}->{parent} );

                                    }

                                }
                            }
                            else {

                                my $var_id =
                                  md5_base64( $script->get_repo_name()
                                      . $script->get_type()
                                      . $script->get_name()
                                      . $script->get_script_name()
                                      . $script->get_last_upd()
                                      . $line );

                                if ( exists( $variables{$var_id} ) ) {

                                    $variables{$var_id}->{is_nullified} = 1;

                                    # parent data will not be necessary anymore
                                    delete( $variables{$var_id}->{parent} );

                                }
                            }
                        }
                    }    # end of when

                    default {

                        print 'Line ignored:', $line, "\n" if (DEBUG);

                    }
                }    # end of given
            }
        }
    }    # end of foreach
}

my $report =
  create_report( \%variables, $cfg->report_filename(), $cfg->report_type() );

print "done. Please check $report file for the generated report\n";

###################################
# SUBS

sub create_report {

    my $var_ref         = shift;
    my $report_filename = shift;
    my $report_type     = shift;

    # remove unwanted keys
    foreach my $var ( keys( %{$var_ref} ) ) {

        delete( $var_ref->{$var} ) if ( $var_ref->{$var}->{is_nullified} );

    }

    given ($report_type) {

        when ('CSV') {

            $report_filename .= '.csv';
            my $path = catfile( getcwd(), $report_filename );
            create_csv( $var_ref, $path );

        }

        when ('XML') {

            $report_filename .= '.xml';
            my $path = catfile( getcwd(), $report_filename );
            create_xml( $var_ref, $path, $cfg->use_xslt() );

        }

        default {

            die
"Don't know report type $report_type: values accepted are CSV or XML\n";

        }

    }

    return $report_filename;

}

sub create_xml {

    my $var_ref  = shift;    #hash ref
    my $path     = shift;
    my $use_xslt = shift;

    my $output = IO::File->new(">$path");

    my $writer = XML::Writer->new( OUTPUT => $output, NEWLINES => 1 );

    $writer->xmlDecl("UTF-8");

    if ( $use_xslt eq 'true' ) {

        $writer->pi( 'xml-stylesheet', 'type="text/xsl" href="style.xsl"' );

    }
    $writer->startTag('issues');

    foreach my $var ( keys( %{$var_ref} ) ) {

        $writer->startTag('issue');
        $writer->dataElement( 'repository', $var_ref->{$var}->{parent}->[0] );
        $writer->dataElement( 'objectType', $var_ref->{$var}->{parent}->[1] );
        $writer->dataElement( 'objectName', $var_ref->{$var}->{parent}->[2] );
        $writer->dataElement( 'function',   $var_ref->{$var}->{parent}->[3] );
        $writer->dataElement( 'lastChangeDate',
            $var_ref->{$var}->{parent}->[4] );
        $writer->dataElement( 'openVariable', $var_ref->{$var}->{name} );
        $writer->dataElement( 'assignMethod',
            $var_ref->{$var}->{assign_method} );
        $writer->endTag('issue');

    }

    $writer->endTag('issues');
    $writer->end();
    $output->close();
}

# TODO: this should be replaced by Text::CSV_XS module
sub create_csv {

    my $var_ref = shift;
    my $path    = shift;

    open( my $csv, '>:utf8', $path )
      or die "Cannot create file $path: $!\n";

    print $csv
"Siebel Repository Name;Object Type;Object Name;Function;Last Change Date;Open Variable;Assignment Method\n";

    foreach my $var ( keys( %{$var_ref} ) ) {

        my $output = join( ';',
            $var_ref->{$var}->{parent}->[0],
            $var_ref->{$var}->{parent}->[1],
            $var_ref->{$var}->{parent}->[2],
            $var_ref->{$var}->{parent}->[3],
            $var_ref->{$var}->{parent}->[4],
            $var_ref->{$var}->{name},
            $var_ref->{$var}->{assign_method} );

        print $csv $output, "\n";

    }

    close($csv);

}

# checks if one of the methods are being used to initilize the variable
sub check_method {

    my @methods_list = (
        'this.BusComp',       'ActiveBusComp',
        'GetBusComp',         'GetAssocBusComp',
        'GetPicklistBusComp', 'this.BusObject',
        'ActiveBusObject',    'GetBusObject',
        'GetService',         'NewPropertySet'
    );

    my $line = shift;

    my $invoke_method;

    foreach my $item (@methods_list) {

        if ( $line =~ /\=.*$item/ ) {

            $invoke_method = $item;
            last;

        }

    }

    return $invoke_method;

}

sub read_config {

    my $cfg_file = shift;

    my $cfg = AppConfig->new(
        { CASE => 1, GLOBAL => { DEFAULT => undef, ARGCOUNT => ARGCOUNT_ONE } }
    );

    $cfg->define('data_source');
    $cfg->define('user');
    $cfg->define('password');
    $cfg->define('maximum_long');
    $cfg->define('report_filename');
    $cfg->define('last_update');
    $cfg->define( 'repository_name', { ARGCOUNT => ARGCOUNT_LIST } );
    $cfg->define( 'verify_runtime',  { VALIDATE => 'true|false' } );
    $cfg->define('report_type');
    $cfg->define( 'skip_inactive', { VALIDATE => 'true|false' } );
    $cfg->define( 'use_xslt',      { VALIDATE => 'true|false' } );

    $cfg->file($cfg_file);

    return $cfg;

}

# adds an array reference with the parent (script) data to a given variable found in the script
sub add_parent_data {

    my $vars_ref = shift;
    my $var_id   = shift;
    my $script   = shift;    # object

    $vars_ref->{$var_id}->{parent} = [
        $script->get_repo_name(), $script->get_type(),
        $script->get_name(),      $script->get_script_name(),
        $script->get_last_upd()
    ];

}

__END__

=pod

=head1 NAME

finder.pl - Connects to a Siebel Server database and runs verifications against all eScript code it finds

=head1 SYNOPSIS

finder.pl [options]

Connects to a Siebel Server database and runs verifications against all eScript code it finds, generating a report at the end of it.

Options:

	--config: complete path to the configuration file to be used (finder.cfg)
	--help: brief help message
	--version: version information about the program

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2012 of Alceu Rodrigues de Freitas Junior, E<lt>arfreitas@cpan.org<E<gt>

This project is based on the code (SiebelOVAnalyzer) provided in the article "Memory Leaks in 
Siebel" (http://siebelunleashed.com/memory-leaks-siebel/) from Timur Vafin. 

This file is part of Siebel Code Analyzer.

Siebel Code Analyzer is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

Siebel Code Analyzer is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with Siebel Monitoring Tools.  If not, see <http://www.gnu.org/licenses/>.

=cut
